home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / tcl / spectcl-.000 / spectcl- / usr / local / SpecTcl-0.1a / forms.tk < prev    next >
Encoding:
Text File  |  1995-11-06  |  6.2 KB  |  207 lines
  1. # SpecTcl, by S. A. Uhler
  2. # Copyright (c) 1994-1995 Sun Microsystems, Inc.
  3. #
  4. # See the file "license.txt" for information on usage and redistribution
  5. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  6. #
  7. # generic fill in the form mega-widget (not done yet) 11/94
  8. # build a data entry form in a frame, inside a scrollable canvas
  9. # The form consists of keyword - value pairs represented as an array.
  10.  
  11. # build_form win form <match>
  12. #  win:    The name of the frame to put this in - it will be created if needed
  13. #  form: The name of the array to fill out the form with
  14. #  height:  How many entries
  15. # side effects:
  16. #  The bind tags "validate" and "entry" are provided for each entry field
  17. #  various options are processed by looking at the Widget_data array
  18. #    ignore:<name>    not placed in the form
  19. #    infilter:<name> processed through an input filter first
  20. #    outfilter:<name> processed through an out filter
  21. #    rename:<name>    the option is re-named as its label
  22.  
  23. # [This needs a re-do]
  24.  
  25. set Advanced 1
  26. proc form_build {win form {option Widget_data} {height 10}} {
  27.     global Advanced
  28.     upvar #0 $form data                ;# name of array with data
  29.     upvar #0 $option config            ;# name of array with configuration stuff
  30.     catch "frame $win"
  31.     if {$win == "."} {set base ""} {set base $win}
  32.     catch "destroy $base.can $base.scroll $base.buttons"
  33.     debug "Building form $form on $win, (base $base)"
  34.  
  35.     # create the canvas, scollbar, and scrolling frame in the canvas
  36.  
  37.     canvas $base.can -yscrollcommand "$base.scroll set"
  38.     scrollbar $base.scroll -orient vertical -command "$base.can yview"
  39.     frame $base.buttons -bg red -bd 1
  40.     set parent $base.can.f
  41.     frame $parent -highlightthickness 0
  42.  
  43.     blt_table $win $base.can     0,1 -fill both
  44.     blt_table $win $base.scroll  0,0 -fill y
  45.     blt_table $win $base.buttons 1,0 -fill x -columnspan 2
  46.     blt_table column $win configure  0 -resize none
  47.     blt_table column $win configure  1 -resize both
  48.     blt_table row $win configure  0 -resize both
  49.     blt_table row $win configure  1 -resize none
  50.     $base.can create window  0 0 -anchor nw -window $parent
  51.     bind $base.can <Configure> {%W itemconfigure all -width %w}
  52.  
  53.  
  54.     # make some buttons
  55.  
  56.     checkbutton $base.buttons.advanced -text "obscure\noptions" \
  57.         -variable Advanced -command "
  58.             form_build $win $form $option $height
  59.             "
  60.     button $base.buttons.quit -text dismiss -command "
  61.             set Geometry([winfo name [winfo toplevel $win]]) \[wm geometry [winfo toplevel $win]\]
  62.             destroy [winfo toplevel $win]
  63.             "
  64.     frame $base.buttons.extra
  65.  
  66.     set col -1
  67.     blt_table $base.buttons $base.buttons.advanced        0,[incr col]  -fill y
  68.     blt_table $base.buttons $base.buttons.quit            0,[incr col]  -fill y
  69.     blt_table $base.buttons $base.buttons.extra            0,[incr col]  -fill both
  70.     blt_table column $base.buttons configure  {0 1} -resize none
  71.     # update ;#?
  72.  
  73.     set row 0
  74.     set prev ""
  75.     set first ""        ;# temp
  76.     foreach item [lsort [array names data]] {
  77.  
  78.         if {!$Advanced && [info exists config(advanced:$item)]} {
  79.             continue
  80.         }
  81.  
  82.         if {[info exists config(ignore:$item)]} {
  83.             continue
  84.         }
  85.  
  86.         if {[info exists config(rename:$item)]} {
  87.             set text $config(rename:$item)
  88.         } else {
  89.             set text $item
  90.         }
  91.  
  92.         # get the value and run the input filter (if any)
  93.  
  94.         set value $data($item)
  95.         if {[info exists config(infilter:$item)]} {
  96.             $config(infilter:$item) value
  97.         }
  98.  
  99.         set label $parent.$form,$item,label    ;# pick something we can parse
  100.         set entry $parent.$form,$item,entry
  101.         label $label -text $text
  102.         entry $entry -bd 3 -relief ridge -width 30
  103.         $entry insert 0 $value
  104.         bindtags $entry "First validate [bindtags $entry]"
  105.         blt_table $parent $label $row,0 -fill none -anchor e
  106.         blt_table $parent $entry $row,1 -fill x -anchor w
  107.         blt_table column $parent configure 0 -resize none
  108.  
  109.         # set tab groupings
  110.         if {$prev != ""} {
  111.             form_bind $base.can $parent $prev $entry
  112.         } else {
  113.             set first $entry
  114.         }
  115.         set prev $entry
  116.         incr row
  117.     }
  118.     form_bind $base.can $parent $prev $first
  119.     foreach i {Return Tab Shift-Tab} {
  120.         bind validate <$i> "check_field %W"
  121.     }
  122.  
  123.     # set the field to "non validated" when the 1st key is pressed
  124.  
  125.     bind validate <FocusIn> "
  126.         set ${form}(focus) %W
  127.         bind validate <KeyPress> {
  128.             %W configure -fg red
  129.             set Current(dirty) 1
  130.             bind validate <KeyPress> {}
  131.             }
  132.         "
  133.  
  134.     # set the canvas parameters nicely
  135.  
  136.     update idletasks
  137.     set incr [blt_table row $parent sizes 0]
  138.     $base.can configure -yscrollincrement $incr \
  139.             -height [expr $height * $incr] \
  140.             -width [winfo reqwidth $parent]
  141.     # eval "$base.can configure -scrollregion \{[$base.can bbox all]\}"
  142.     $base.can yview moveto 0
  143.     scrollregion_update $parent
  144.  
  145.     # this is a kludge to work around a focus bug in this version of TK
  146.  
  147.     if {[info exists data(focus)] && [winfo exists $data(focus)]} {
  148.         # after 300 focus $data(focus)
  149.         focus $data(focus)
  150.     } else {
  151.         # after 300 focus $first
  152.         focus $first
  153.     }
  154. #    after 300 "raise [winfo toplevel $win]"
  155.     return $win
  156. }
  157.  
  158. # set the key bindings for tabbing through entry fields
  159.  
  160. proc form_bind {canvas frame prev next} {
  161.     bind $prev <Tab> "focus $next" 
  162.     bind $next <Shift-Tab> "focus $prev" 
  163.     bind $next <FocusIn> "form_focus $canvas $frame $next" 
  164. }
  165.  
  166. # focus and make visible (by scrolling canvas as needed)
  167.  
  168. proc form_focus {canvas frame item} {
  169.     $item selection range 0 end
  170.     dputs $item
  171.     set below [expr [winfo y $item] + [winfo y $frame]]
  172.     if {$below <= 0 } {
  173.         $canvas yview scroll \
  174.             [expr $below/[$canvas cget -yscrollincrement]] units
  175.         return -1
  176.     }
  177.     set above [expr [winfo y $item] + [winfo y $frame] - \
  178.             ([winfo height $canvas] - [winfo height $item])]
  179.     if {$above > 0} {
  180.         $canvas yview scroll \
  181.             [expr $above/[$canvas cget -yscrollincrement]+1] units
  182.         return 1
  183.     }
  184.     return 0
  185. }
  186.  
  187. # validate a field entry - this is done any time the field is "left"
  188. # This is called from "bind" and causes the remaining bindings to be
  189. # skipped if the validation fails
  190. # errors (if any) are placed in the "error" entry of the array, which is displayed on the form
  191. #   win:    the name of the entry window, from which re can derive the widget info
  192.  
  193. proc check_field {win} {
  194.     regexp {.*\.([^,]+),([^,]+),} $win dummy name item
  195.     set value [$win get]
  196.     dputs $name: $item<-$value
  197.     upvar #0 $name data
  198.     set data(error) [validate_field $name $item $value]
  199.     if {$data(error) != {}} {
  200.         focus $win
  201.         return -code break
  202.     } else {
  203.         $win configure -fg black
  204.         return
  205.     }
  206. }
  207.